home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmptop.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  33KB  |  816 lines
  1. ;;; CMPTOP  Compiler top-level.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defvar *objects* nil)
  10. (defvar *constants* nil)
  11. (defvar *sharp-commas* nil)
  12.  
  13. ;;; *objects* holds ( { object vv-index }* ).
  14. ;;; *constants* holds ( { symbol vv-index }* ).
  15. ;;; *sharp-commas* holds ( vv-index* ), indicating that the value
  16. ;;;  of each vv should be turned into an object from a string before
  17. ;;;  defining the current function during loading process, so that
  18. ;;;  sharp-comma-macros may be evaluated correctly.
  19.  
  20. (defvar *global-funs* nil)
  21.  
  22. ;;; *global-funs* holds
  23. ;;;     ( { global-fun-name cfun }* )
  24.  
  25. (defvar *closures* nil)
  26. (defvar *local-funs* nil)
  27.  
  28. ;;; *closure* holds fun-objects for closures.
  29.  
  30. (defvar *compile-time-too* nil)
  31. (defvar *eval-when-compile* t)
  32. (defvar *top-level-forms* nil)
  33. (defvar *non-package-operation* nil)
  34.  
  35. ;;; *top-level-forms* holds ( { top-level-form }* ).
  36. ;;;
  37. ;;;     top-level-form:
  38. ;;;      ( 'DEFUN'     fun-name cfun lambda-expr doc-vv sp)
  39. ;;;    | ( 'DEFMACRO'  macro-name cfun lambda-expr doc-vv sp)
  40. ;;;    | ( 'ORDINARY'  cfun expr)
  41. ;;;    | ( 'DECLARE'   var-name-vv )
  42. ;;;    | ( 'DEFVAR'    var-name-vv expr doc-vv)
  43. ;;;    | ( 'CLINES'    string )
  44. ;;;    | ( 'DEFCFUN'    header vs-size body)
  45. ;;;    | ( 'DEFENTRY'    fun-name cfun cvspecs type cfun-name )
  46. ;;;    | ( 'SHARP-COMMA' vv )
  47.  
  48. (defvar *reservations* nil)
  49. (defvar *reservation-cmacro* nil)
  50.  
  51. ;;; *reservations* holds (... ( cmacro . value ) ...).
  52. ;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
  53.  
  54. (defvar *global-entries* nil)
  55.  
  56. ;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
  57.  
  58. ;;; Package operations.
  59.  
  60. (si:putprop 'make-package t 'package-operation)
  61. (si:putprop 'in-package t 'package-operation)
  62. (si:putprop 'shadow t 'package-operation)
  63. (si:putprop 'shadowing-import t 'package-operation)
  64. (si:putprop 'export t 'package-operation)
  65. (si:putprop 'unexport t 'package-operation)
  66. (si:putprop 'use-package t 'package-operation)
  67. (si:putprop 'unuse-package t 'package-operation)
  68. (si:putprop 'import t 'package-operation)
  69. (si:putprop 'provide t 'package-operation)
  70. (si:putprop 'require t 'package-operation)
  71.  
  72. ;;; Pass 1 top-levels.
  73.  
  74. (si:putprop 'eval-when 't1eval-when 't1)
  75. (si:putprop 'progn 't1progn 't1)
  76. (si:putprop 'defun 't1defun 't1)
  77. (si:putprop 'defmacro 't1defmacro 't1)
  78. (si:putprop 'clines 't1clines 't1)
  79. (si:putprop 'defcfun 't1defcfun 't1)
  80. (si:putprop 'defentry 't1defentry 't1)
  81. (si:putprop 'defla 't1defla 't1)
  82. (si:putprop 'defvar 't1defvar 't1)
  83.  
  84. ;;; Top-level macros.
  85.  
  86. (si:putprop 'defconstant t 'top-level-macro)
  87. (si:putprop 'defparameter t 'top-level-macro)
  88. (si:putprop 'defstruct t 'top-level-macro)
  89. (si:putprop 'deftype t 'top-level-macro)
  90. (si:putprop 'defsetf t 'top-level-macro)
  91.  
  92. ;;; Pass 2 initializers.
  93.  
  94. (si:putprop 'defun 't2defun 't2)
  95. (si:putprop 'defmacro 't2defmacro 't2)
  96. (si:putprop 'ordinary 't2ordinary 't2)
  97. (si:putprop 'declare 't2declare 't2)
  98. (si:putprop 'sharp-comma 't2sharp-comma 't2)
  99. (si:putprop 'defentry 't2defentry 't2)
  100. (si:putprop 'defvar 't2defvar 't2)
  101.  
  102. ;;; Pass 2 C function generators.
  103.  
  104. (si:putprop 'defun 't3defun 't3)
  105. (si:putprop 'defmacro 't3defmacro 't3)
  106. (si:putprop 'clines 't3clines 't3)
  107. (si:putprop 'defcfun 't3defcfun 't3)
  108. (si:putprop 'defentry 't3defentry 't3)
  109.  
  110.  
  111. (defun t1expr (form &aux (*current-form* form) (*first-error* t))
  112.   (catch *cmperr-tag*
  113.     (when (consp form)
  114.       (let ((fun (car form)) (args (cdr form)) fd)
  115.            (declare (object fun args))
  116.            (cond
  117.             ((symbolp fun)
  118.              (cond ((eq fun 'si:|#,|)
  119.                     (cmperr "Sharp-comma-macro is in a bad place."))
  120.                    ((get fun 'package-operation)
  121.                     (when *non-package-operation*
  122.                       (cmpwarn "The package operation ~s was in a bad place."
  123.                                form))
  124.                     (when *compile-time-too* (cmp-eval form))
  125.                     (wt-data-package-operation form))
  126.                    ((setq fd (get fun 't1))
  127.                     (when *compile-print* (print-current-form))
  128.                     (funcall fd args))
  129.                    ((get fun 'top-level-macro)
  130.                     (when *compile-print* (print-current-form))
  131.                     (t1expr (cmp-macroexpand-1 form)))
  132.                    ((get fun 'c1) (t1ordinary form))
  133.                    ((setq fd (macro-function fun))
  134.                     (t1expr (cmp-expand-macro fd fun (cdr form))))
  135.                    (t (t1ordinary form))
  136.                    ))
  137.             ((consp fun) (t1ordinary form))
  138.             (t (cmperr "~s is illegal function." fun)))
  139.            )))
  140.   )
  141.  
  142. (defun ctop-write (name &aux (vv-reservation (next-cmacro)) def)
  143.  
  144.   (setq *top-level-forms* (reverse *top-level-forms*))
  145.  
  146.   ;;; Initialization function.
  147.   (let ((*vs* 0) (*max-vs* 0) (*clink* nil) (*ccb-vs* 0) (*level* 0)
  148.                  (*reservation-cmacro* (next-cmacro)))
  149.        (wt-nl1
  150.         "init_" name "(start,size,data)char *start;int size;object data;")
  151.        (wt-nl1 "{    register object *base=vs_top;"
  152.                "register object *sup=base+VM" *reservation-cmacro*
  153.                ";vs_top=sup;vs_check;")
  154.        (wt-nl "Cstart=start;Csize=size;Cdata=data;set_VV(VV,VM"
  155.               vv-reservation ",data);")
  156.  
  157.        (dolist* (form *top-level-forms*)
  158.                 (when (setq def (get (car form) 't2))
  159.                       (apply def (cdr form))))
  160.        (wt-nl "vs_top=vs_base=base;")
  161.        (wt-nl1 "}")
  162.        (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  163.        )
  164.  
  165.   ;;; C function definitions.
  166.   (dolist* (form *top-level-forms*)
  167.            (when (setq def (get (car form) 't3))
  168.                  (apply def (cdr form))))
  169.  
  170.   ;;; Local function and closure function definitions.
  171.   (let (lf)
  172.        (block local-fun-process
  173.          (loop
  174.           (when (endp *local-funs*) (return-from local-fun-process))
  175.           (setq lf (car *local-funs*))
  176.           (pop *local-funs*)
  177.           (apply 't3local-fun lf))))
  178.  
  179.   ;;; Global entries for directly called functions.
  180.  
  181.   (dolist* (x *global-entries*)
  182.            (apply 'wt-global-entry x))
  183.  
  184.   ;;; Declarations in h-file.
  185.   (wt-h "static char *Cstart;static int Csize;static object Cdata;")
  186.   (dolist* (fun *closures*) (wt-h "static LC" (fun-cfun fun) "();"))
  187.   (dolist* (x *reservations*)
  188.            (wt-h "#define VM" (car x) " " (cdr x)))
  189.   (incf *next-vv*)
  190.   (wt-h "#define VM" vv-reservation " " *next-vv*)
  191.   (if (zerop *next-vv*)
  192.       (wt-h "static object VV[1];")
  193.       (wt-h "static object VV[" *next-vv* "];"))
  194.   )
  195.  
  196. (defun t1eval-when (args &aux (load-flag nil) (compile-flag nil)
  197.                               (eval-flag nil))
  198.   (declare (object load-flag compile-flag eval-flag))
  199.   (when (endp args) (too-few-args 'eval-when 1 0))
  200.   (dolist** (situation (car args))
  201.     (case situation
  202.           (load (setq load-flag t))
  203.           (compile (setq compile-flag t))
  204.           (eval (setq eval-flag t))
  205.           (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal."
  206.                              situation))))
  207.   (cond (load-flag
  208.           (let ((*compile-time-too*
  209.                  (or compile-flag (and *compile-time-too* eval-flag))))
  210.             (dolist** (form (cdr args)) (t1expr form))))
  211.         ((or compile-flag (and *compile-time-too* eval-flag))
  212.          (setq *non-package-operation* t)
  213.          (dolist** (form (cdr args)) (cmp-eval form))))
  214.   )
  215.  
  216. (defun t1progn (args) (dolist** (form args) (t1expr form)))
  217.  
  218. (defun t1defun (args)
  219.   (when (or (endp args) (endp (cdr args)))
  220.         (too-few-args 'defun 2 (length args)))
  221.   (cmpck (not (symbolp (car args)))
  222.          "The function name ~s is not a symbol." (car args))
  223.   (when *compile-time-too* (cmp-eval (cons 'defun args)))
  224.   (setq *non-package-operation* t)
  225.   (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr
  226.         (*sharp-commas* nil) (*special-binding* nil)
  227.         (cfun (or (get (car args) 'Ufun) (next-cfun)))
  228.         (doc nil) (fname (car args)))
  229.        (declare (object fname))
  230.        (setq lambda-expr (c1lambda-expr (cdr args) fname))
  231.        (when (cadddr lambda-expr)
  232.              (setq doc (add-object (cadddr lambda-expr))))
  233.        (add-load-time-sharp-comma)
  234.        (push (list 'defun fname cfun lambda-expr doc *special-binding*)
  235.              *top-level-forms*)
  236.        (push (cons fname cfun) *global-funs*)
  237.  
  238.        (when
  239.         (and
  240.          (get fname 'proclaimed-function)
  241.          (let ((lambda-list (caddr lambda-expr)))
  242.               (declare (object lambda-list))
  243.               (and (null (cadr lambda-list))    ;;; no optional
  244.                    (null (caddr lambda-list))    ;;; no rest
  245.                    (null (cadddr lambda-list))    ;;; no keyword
  246.                    (< (length (car lambda-list)) 10)
  247.                         ;;; less than 10 requireds
  248.                    ;;; For all required parameters...
  249.                    (do ((vars (car lambda-list) (cdr vars))
  250.                         (types (get fname 'proclaimed-arg-types) (cdr types)))
  251.                        ((endp vars)
  252.                         (endp types))
  253.                        (declare (object vars types))
  254.                        (let ((var (car vars)))
  255.                             (declare (object var))
  256.                             (unless
  257.                              (and (eq (var-kind var) 'LEXICAL)
  258.                                   (not (var-ref-ccb var))
  259.                                   (not (eq (var-loc var) 'clb))
  260.                                   (type-and (car types) (var-type var))
  261.                                   (or (member (car types)
  262.                                               '(fixnum character
  263.                                                 long-float short-float))
  264.                                       (eq (var-loc var) 'object)
  265.                                       (not (member var
  266.                                                    (info-changed-vars
  267.                                                     (cadr lambda-expr)))))
  268.                                     )
  269.                              (return nil))))))
  270.          (numberp cfun))
  271.         (push (list fname
  272.                     (get fname 'proclaimed-arg-types)
  273.                     (get fname 'proclaimed-return-type)
  274.                     t
  275.                     (not (member (get fname 'proclaimed-return-type)
  276.                                  '(fixnum character long-float short-float)))
  277.                     (make-inline-string
  278.                      cfun (get fname 'proclaimed-arg-types)))
  279.               *inline-functions*))
  280.        )
  281.   )
  282.  
  283. (defun make-inline-string (cfun args)
  284.   (if (null args)
  285.       (format nil "LI~d()" cfun)
  286.       (let ((o (make-array 100 :element-type 'string-char :fill-pointer 0)))
  287.            (format o "LI~d(" cfun)
  288.            (do ((l args (cdr l))
  289.                 (n 0 (1+ n)))
  290.                ((endp (cdr l))
  291.                 (format o "#~d)" n))
  292.                (declare (fixnum n))
  293.                (format o "#~d," n))
  294.            o)))
  295.  
  296. (defun t2defun (fname cfun lambda-expr doc sp &aux (vv (add-symbol fname)))
  297.   (declare (ignore lambda-expr sp))
  298.   (when doc
  299.     (wt-nl "(void)putprop(VV[" vv "],VV[" doc "],siSfunction_documentation);")
  300.     (wt-nl) (reset-top)
  301.     )
  302.   (cond ((numberp cfun)
  303.          (wt-h "static L" cfun "();")
  304.          (wt-nl "MF(VV[" vv "],L" cfun ",start,size,data);"))
  305.         (t (wt-h cfun "();")
  306.            (wt-nl "MF(VV[" vv "]," cfun ",start,size,data);")))
  307.   )
  308.  
  309. (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info requireds)
  310.   (declare (ignore doc) (object requireds))
  311.   (cond
  312.    ((setq inline-info (assoc fname *inline-functions*))
  313.     (setq requireds (caaddr lambda-expr))
  314.  
  315.     ;;; Add global entry information.
  316.     (push (list fname cfun (cadr inline-info) (caddr inline-info))
  317.           *global-entries*)
  318.  
  319.     ;;; Local entry
  320.     (let* ((*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil)
  321.            (*exit* (case (caddr inline-info)
  322.                          (fixnum 'return-fixnum)
  323.                          (character 'return-character)
  324.                          (long-float 'return-long-float)
  325.                          (short-float 'return-short-float)
  326.                          (otherwise 'return-object)))
  327.            (*unwind-exit* (list *exit*))
  328.            (*value-to-go* *exit*)
  329.            (*reservation-cmacro* (next-cmacro))
  330.            (*sup-used* nil)
  331.            (*base-used* nil))
  332.  
  333.          (do ((vl requireds (cdr vl))
  334.               (types (cadr inline-info) (cdr types)))
  335.              ((endp vl))
  336.              (declare (object vl types))
  337.              (setf (var-kind (car vl))
  338.                    (case (car types)
  339.                          (fixnum 'FIXNUM)
  340.                          (character 'CHARACTER)
  341.                          (long-float 'LONG-FLOAT)
  342.                          (short-float 'SHORT-FLOAT)
  343.                          (otherwise 'OBJECT))
  344.                    )
  345.              (setf (var-loc (car vl)) (next-cvar)))
  346.          (wt-comment "local entry for function " fname)
  347.          (wt-h "static " (rep-type (caddr inline-info)) "LI" cfun "();")
  348.          (wt-nl1 "static " (rep-type (caddr inline-info)) "LI" cfun "(")
  349.          (do ((vl requireds (cdr vl)))
  350.              ((endp vl))
  351.              (declare (object vl))
  352.              (let ((cvar (next-cvar)))
  353.                   (setf (var-loc (car vl)) cvar)
  354.                   (wt "V" cvar))
  355.              (unless (endp (cdr vl)) (wt ",")))
  356.          (wt ")")
  357.          (when requireds
  358.                (wt-nl1)
  359.                (do ((vl requireds (cdr vl))
  360.                     (types (cadr inline-info) (cdr types))
  361.                     (prev-type nil))
  362.                    ((endp vl) (wt ";"))
  363.                    (declare (object vl))
  364.                    (if prev-type
  365.                        (if (eq (car types) prev-type)
  366.                            (wt ",")
  367.                            (wt ";" (rep-type (car types))))
  368.                        (wt (rep-type (car types))))
  369.                    (setq prev-type (car types))
  370.                    (wt "V" (var-loc (car vl)))))
  371.  
  372.          ;;; Now the body.
  373.          (let ((cm *reservation-cmacro*)
  374.            (*tail-recursion-info*
  375.             (if *do-tail-recursion* (cons fname requireds) nil))
  376.            (*unwind-exit* *unwind-exit*))
  377.               (wt-nl1 "{    VMB" cm " VMS" cm " VMV" cm)
  378.               (when sp (wt-nl "bds_check;"))
  379.               (when *compiler-push-events* (wt-nl "ihs_check;"))
  380.               (when *tail-recursion-info*
  381.                     (push 'tail-recursion-mark *unwind-exit*)
  382.                     (wt-nl1 "TTL:;"))
  383.               (c2expr (caddr (cddr lambda-expr)))
  384.               (wt-nl1 "}")
  385.               (push (cons cm *max-vs*) *reservations*)
  386.               (if (and (zerop *max-vs*) (not *base-used*))
  387.                   (wt-h "#define VMB" cm)
  388.                   (wt-h "#define VMB" cm " register object *base=vs_top;"))
  389.               (if *sup-used*
  390.                   (wt-h "#define VMS" cm
  391.                         " register object *sup=vs_top+" *max-vs*
  392.                         ";vs_top=sup;")
  393.                   (if (zerop *max-vs*)
  394.                       (wt-h "#define VMS" cm)
  395.                       (wt-h "#define VMS" cm " vs_top += " *max-vs* ";")))
  396.               (if (zerop *max-vs*)
  397.                   (wt-h "#define VMV" cm)
  398.                   (if *safe-compile*
  399.                       (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");")
  400.                       (wt-h "#define VMV" cm " vs_check;")))
  401.               (if (zerop *max-vs*)
  402.                   (wt-h "#define VMR" cm "(VMT" cm ") return(VMT" cm ");")
  403.                   (if (member (caddr inline-info)
  404.                               '(fixnum character long-float short-float))
  405.                       (let ((cvar (next-cvar)))
  406.                            (wt-h "#define VMR" cm "(VMT" cm ")"
  407.                                 " {" (rep-type (caddr inline-info)) "V" cvar
  408.                                 "=VMT" cm ";vs_top=base;return(V" cvar ");}"))
  409.                       (wt-h "#define VMR" cm "(VMT" cm ")"
  410.                         " {CMPtemp=VMT" cm ";vs_top=base;return(CMPtemp);}")))
  411.               )
  412.          ))
  413.    (t
  414.     (let ((*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil)
  415.           (*exit* 'return) (*unwind-exit* '(return))
  416.           (*value-to-go* 'return) (*reservation-cmacro* (next-cmacro)))
  417.  
  418.          (wt-comment "function definition for " fname)
  419.          (if (numberp cfun)
  420.              (wt-nl1 "static L" cfun "()")
  421.              (wt-nl1 cfun "()"))
  422.          (wt-nl1 "{    register object *base=vs_base;")
  423.          (wt-nl "register object *sup=base+VM" *reservation-cmacro* ";")
  424.          (if *safe-compile*
  425.              (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  426.              (wt-nl "vs_check;"))
  427.          (when sp (wt-nl "bds_check;"))
  428.          (when *compiler-push-events* (wt-nl "ihs_check;"))
  429.          (c2lambda-expr (caddr lambda-expr) (caddr (cddr lambda-expr)) fname)
  430.          (wt-nl1 "}")
  431.          (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  432.          )))
  433.   )
  434.  
  435. (defun wt-global-entry (fname cfun arg-types return-type)
  436.     (wt-comment "global entry for the function " fname)
  437.     (wt-nl1 "static L" cfun "()")
  438.     (wt-nl1 "{    register object *base=vs_base;")
  439.     (when (or *safe-compile* *compiler-check-args*)
  440.           (wt-nl "check_arg(" (length arg-types) ");"))
  441.     (wt-nl "base[0]=" (case return-type
  442.                             (fixnum (if (zerop *space*)
  443.                                         "CMPmake_fixnum"
  444.                                         "make_fixnum"))
  445.                             (character "code_char")
  446.                             (long-float "make_longfloat")
  447.                             (short-float "make_shortfloat")
  448.                             (otherwise ""))
  449.            "(LI" cfun "(")
  450.     (do ((types arg-types (cdr types))
  451.          (n 0 (1+ n)))
  452.         ((endp types))
  453.         (declare (object types) (fixnum n))
  454.         (wt (case (car types)
  455.                   (fixnum "fix")
  456.                   (character "char_code")
  457.                   (long-float "lf")
  458.                   (short-float "sf")
  459.                   (otherwise ""))
  460.             "(base[" n "])")
  461.         (unless (endp (cdr types)) (wt ",")))
  462.     (wt "));")
  463.     (wt-nl "vs_top=(vs_base=base)+1;")
  464.     (wt-nl1 "}")
  465.     )
  466.  
  467. (defun rep-type (type)
  468.        (case type
  469.              (fixnum "int ")
  470.              (character "unsigned char ")
  471.              (short-float "float ")
  472.              (long-float "double ")
  473.              (otherwise "object ")))
  474.  
  475.  
  476. (defun t1defmacro (args)
  477.   (when (or (endp args) (endp (cdr args)))
  478.         (too-few-args 'defmacro 2 (length args)))
  479.   (cmpck (not (symbolp (car args)))
  480.          "The macro name ~s is not a symbol." (car args))
  481.   (when *compile-time-too* (cmp-eval (cons 'defmacro args)))
  482.   (setq *non-package-operation* t)
  483.   (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
  484.         (*sharp-commas* nil) (*special-binding* nil)
  485.         macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil))
  486.        (setq macro-lambda (c1dm (car args) (cadr args) (cddr args)))
  487.        (when (car macro-lambda) (setq doc (add-object (car macro-lambda))))
  488.        (when (cadr macro-lambda) (setq ppn (add-object (cadr macro-lambda))))
  489.        (add-load-time-sharp-comma)
  490.        (push (list 'defmacro (car args) cfun (cddr macro-lambda) doc ppn
  491.                    *special-binding*)
  492.              *top-level-forms*))
  493.   )
  494.  
  495. (defun t2defmacro (fname cfun macro-lambda doc ppn sp
  496.                          &aux (vv (add-symbol fname)))
  497.   (declare (ignore macro-lambda sp))
  498.   (when doc
  499.     (wt-nl "(void)putprop(VV[" vv "],VV[" doc "],siSfunction_documentation);")
  500.     (wt-nl) (reset-top))
  501.   (when ppn
  502.     (wt-nl "(void)putprop(VV[" vv "],VV[" ppn "],siSpretty_print_format);")
  503.     (wt-nl) (reset-top))
  504.   (wt-h "static L" cfun "();")
  505.   (wt-nl "MM(VV[" vv "],L" cfun ",start,size,data);")
  506.   )
  507.  
  508. (defun t3defmacro (fname cfun macro-lambda doc ppn sp
  509.                          &aux (*vs* 0) (*max-vs* 0)
  510.                          (*clink* nil) (*ccb-vs* 0) (*level* 0)
  511.                          (*exit* 'return) (*unwind-exit* '(return))
  512.                          (*value-to-go* 'return)
  513.                          (*reservation-cmacro* (next-cmacro)))
  514.   (declare (ignore doc ppn))
  515.   (wt-comment "macro definition for " fname)
  516.   (wt-nl1 "static L" cfun "()")
  517.   (wt-nl1 "{    register object *base=vs_base;")
  518.   (wt-nl "register object *sup=base+VM" *reservation-cmacro* ";")
  519.   (if *safe-compile*
  520.       (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  521.       (wt-nl "vs_check;"))
  522.   (when sp (wt-nl "bds_check;"))
  523.   (when *compiler-push-events* (wt-nl "ihs_check;"))
  524.   (c2dm (car macro-lambda) (cadr macro-lambda) (caddr macro-lambda)
  525.         (cadddr macro-lambda))
  526.   (wt-nl1 "}")
  527.   (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  528.   )
  529.  
  530. (defun t1ordinary (form)
  531.   (when *compile-time-too* (cmp-eval form))
  532.   (setq *non-package-operation* t)
  533.   (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
  534.         (*sharp-commas* nil))
  535.        (setq form (c1expr form))
  536.        (add-load-time-sharp-comma)
  537.        (push (list 'ordinary (next-cfun) form) *top-level-forms*)))
  538.  
  539. (defun t2ordinary (cfun form)
  540.   (declare (ignore cfun))
  541.   (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
  542.          (*value-to-go* 'trash))
  543.         (c2expr form)
  544.         (wt-label *exit*)))
  545.  
  546. (defun add-load-time-sharp-comma ()
  547.   (dolist* (vv (reverse *sharp-commas*))
  548.     (push (list 'sharp-comma vv) *top-level-forms*)))
  549.  
  550. (defun t2sharp-comma (vv)
  551.   (wt-nl "data->v.v_self[" vv "]=VV[" vv "]=string_to_object(VV[" vv "]);")
  552.   (wt-nl) (reset-top))
  553.  
  554. (defun t2declare (vv)
  555.   (wt-nl "VV[" vv "]->s.s_stype=(short)stp_special;"))
  556.  
  557. (defun t1defvar (args &aux form (doc nil))
  558.   (when *compile-time-too* (cmp-eval `(defvar ,@args)))
  559.   (setq *non-package-operation* nil)
  560.   (cond ((endp (cdr args))
  561.          (push (list 'declare (add-symbol (car args))) *top-level-forms*))
  562.         (t
  563.          (unless (endp (cddr args)) (setq doc (add-object (caddr args))))
  564.          (let* ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
  565.                 (*sharp-commas* nil))
  566.                (setq form (c1expr (cadr args)))
  567.                (add-load-time-sharp-comma))
  568.          (push (list 'defvar (add-symbol (car args)) form doc)
  569.                *top-level-forms*)))
  570.   )
  571.  
  572. (defun t2defvar (vv form doc)
  573.   (wt-nl "VV[" vv "]->s.s_stype=(short)stp_special;")
  574.   (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
  575.          (*value-to-go* (list 'DBIND vv)))
  576.         (wt-nl "if(VV[" vv "]->s.s_dbind == OBJNULL){")
  577.         (c2expr form)
  578.         (wt "}")
  579.         (wt-label *exit*))
  580.   (when doc
  581.     (wt-nl "(void)putprop(VV[" vv "],VV[" doc "],siSvariable_documentation);")
  582.     (wt-nl) (reset-top)
  583.     )
  584.   )
  585.  
  586. (si:putprop 'dbind 'set-dbind 'set-loc)
  587.  
  588. (defun set-dbind (loc vv)
  589.   (wt-nl "VV[" vv "]->s.s_dbind = " loc ";"))
  590.  
  591. (defun t1clines (args)
  592.   (dolist** (s args)
  593.     (cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s))
  594.   (push (list 'clines args) *top-level-forms*))
  595.  
  596. (defun t3clines (ss) (dolist** (s ss) (wt-nl1 s)))
  597.  
  598. (defun t1defcfun (args &aux (body nil))
  599.   (when (or (endp args) (endp (cdr args)))
  600.         (too-few-args 'defcfun 2 (length args)))
  601.   (cmpck (not (stringp (car args)))
  602.          "The first argument to defCfun ~s is not a string." (car args))
  603.   (cmpck (not (numberp (cadr args)))
  604.          "The second argument to defCfun ~s is not a number." (cadr args))
  605.   (dolist** (s (cddr args))
  606.     (cond ((stringp s) (push s body))
  607.           ((consp s)
  608.            (cond ((symbolp (car s))
  609.                   (cmpck (special-form-p (car s))
  610.                          "Special form ~s is not allowed in defCfun." (car s))
  611.                   (push (list (cons (car s) (parse-cvspecs (cdr s)))) body))
  612.                  ((and (consp (car s)) (symbolp (caar s))
  613.                        (not (if (eq (caar s) 'quote)
  614.                                 (or (endp (cdar s))
  615.                                     (not (endp (cddar s)))
  616.                                     (endp (cdr s))
  617.                                     (not (endp (cddr s))))
  618.                                 (special-form-p (caar s)))))
  619.                   (push (cons (cons (caar s)
  620.                                     (if (eq (caar s) 'quote)
  621.                                         (list (add-object (cadar s)))
  622.                                         (parse-cvspecs (cdar s))))
  623.                               (parse-cvspecs (cdr s)))
  624.                         body))
  625.                  (t (cmperr "The defCfun body ~s is illegal." s))))
  626.           (t (cmperr "The defCfun body ~s is illegal." s))))
  627.   (push (list 'defcfun (car args) (cadr args) (reverse body))
  628.         *top-level-forms*)
  629.   )
  630.  
  631. (defun t3defcfun (header vs-size body &aux fd)
  632.   (wt-comment "C function defined by " 'defcfun)
  633.   (wt-nl1 header)
  634.   (wt-nl1 "{")
  635.   (wt-nl1 "object *vs=vs_top;")
  636.   (wt-nl1 "object *old_top=vs_top+" vs-size ";")
  637.   (when (> vs-size 0) (wt-nl "vs_top=old_top;"))
  638.   (wt-nl1 "{")
  639.   (dolist** (s body)
  640.     (cond ((stringp s) (wt-nl1 s))
  641.           ((eq (caar s) 'quote)
  642.            (wt-nl1 (cadadr s))
  643.            (case (caadr s)
  644.                  (object (wt "=VV[" (cadar s) "];"))
  645.                  (otherwise
  646.                   (wt "=object_to_" (string-downcase (symbol-name (caadr s)))
  647.                       "(VV[" (cadar s) "]);"))))
  648.           (t (wt-nl1 "{vs_base=vs_top=old_top;")
  649.              (dolist** (arg (cdar s))
  650.                (wt-nl1 "vs_push(")
  651.                (case (car arg)
  652.                      (object (wt (cadr arg)))
  653.                      (char (wt "code_char((int)" (cadr arg) ")"))
  654.                      (int (when (zerop *space*) (wt "CMP"))
  655.                           (wt "make_fixnum((int)" (cadr arg) ")"))
  656.                      (float (wt "make_shortfloat((double)" (cadr arg) ")"))
  657.                      (double (wt "make_longfloat((double)" (cadr arg) ")")))
  658.                (wt ");"))
  659.              (cond ((setq fd (assoc (caar s) *global-funs*))
  660.                     (cond (*compiler-push-events*
  661.                            (wt-nl1 "ihs_push(VV[" (add-symbol (caar s)) "]);")
  662.                            (wt-nl1 "L" (cdr fd) "();")
  663.                            (wt-nl1 "ihs_pop();"))
  664.                           (t (wt-nl1 "L" (cdr fd) "();"))))
  665.                    (*compiler-push-events*
  666.                     (wt-nl1 "super_funcall(VV[" (add-symbol (caar s)) "]);"))
  667.                    (*safe-compile*
  668.                     (wt-nl1 "super_funcall_no_event(VV[" (add-symbol (caar s))
  669.                                                         "]);"))
  670.                    (t (wt-nl1 "CMPfuncall(VV[" (add-symbol (caar s))
  671.                                               "]->s.s_gfdef);"))
  672.                    )
  673.              (unless (endp (cdr s))
  674.                (wt-nl1 (cadadr s))
  675.                (case (caadr s)
  676.                      (object (wt "=vs_base[0];"))
  677.                      (otherwise (wt "=object_to_"
  678.                                     (string-downcase (symbol-name (caadr s)))
  679.                                     "(vs_base[0]);")))
  680.                (dolist** (dest (cddr s))
  681.                  (wt-nl1 "vs_base++;")
  682.                  (wt-nl1 (cadr dest))
  683.                  (case (car dest)
  684.                        (object
  685.                         (wt "=(vs_base<vs_top?vs_base[0]:Cnil);"))
  686.                        (otherwise
  687.                         (wt "=object_to_"
  688.                             (string-downcase (symbol-name (car dest)))
  689.                             "((vs_base<vs_top?vs_base[0]:Cnil));"))))
  690.                )
  691.              (wt-nl1 "}")
  692.              )))
  693.   (wt-nl1 "}")
  694.   (wt-nl1 "vs_top=vs;")
  695.   (wt-nl1 "}")
  696.   )
  697.  
  698. (defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec)
  699.   (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
  700.         (too-few-args 'defentry 3 (length args)))
  701.   (cmpck (not (symbolp (car args)))
  702.          "The function name ~s is not a symbol." (car args))
  703.   (dolist** (x (cadr args))
  704.     (cmpck (not (member x '(object char int float double)))
  705.            "The C-type ~s is illegal." x))
  706.   (setq cfspec (caddr args))
  707.   (cond ((symbolp cfspec)
  708.          (setq type 'object)
  709.          (setq cname (string-downcase (symbol-name cfspec))))
  710.         ((stringp cfspec)
  711.          (setq type 'object)
  712.          (setq cname cfspec))
  713.         ((and (consp cfspec)
  714.               (member (car cfspec) '(void object char int float double))
  715.               (consp (cdr cfspec))
  716.               (or (symbolp (cadr cfspec)) (stringp (cadr cfspec)))
  717.               (endp (cddr cfspec)))
  718.          (setq cname (if (symbolp (cadr cfspec))
  719.                         (string-downcase (symbol-name (cadr cfspec)))
  720.                         (cadr cfspec)))
  721.          (setq type (car cfspec)))
  722.         (t (cmperr "The C function specification ~s is illegal." cfspec)))
  723.   (push (list 'defentry (car args) cfun (cadr args) type cname)
  724.         *top-level-forms*)
  725.   (push (cons (car args) cfun) *global-funs*)
  726.   )
  727.  
  728. (defun t2defentry (fname cfun arg-types type cname
  729.                          &aux (vv (add-symbol fname)))
  730.   (declare (ignore arg-types type cname))
  731.   (wt-h "static L" cfun "();")
  732.   (wt-nl "MF(VV[" vv "],L" cfun ",start,size,data);")
  733.   )
  734.  
  735. (defun t3defentry (fname cfun arg-types type cname)
  736.   (wt-comment "function definition for " fname)
  737.   (wt-nl1 "static L" cfun "()")
  738.   (wt-nl1 "{    object *old_base=vs_base;")
  739.   (unless (eq type 'void) (wt-nl (string-downcase (symbol-name type)) " x;"))
  740.   (when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");"))
  741.   (unless (eq type 'void) (wt-nl "x="))
  742.   (wt-nl cname "(")
  743.   (unless (endp arg-types)
  744.           (do ((types arg-types (cdr types))
  745.                (i 0 (1+ i)))
  746.               (nil)
  747.               (declare (object types) (fixnum i))
  748.               (case (car types)
  749.                     (object (wt-nl "vs_base[" i "]"))
  750.                     (otherwise
  751.                      (wt-nl "object_to_"
  752.                             (string-downcase (symbol-name (car types)))
  753.                             "(vs_base[" i "])")))
  754.               (when (endp (cdr types)) (return))
  755.               (wt ",")))
  756.   (wt ");")
  757.   (wt-nl "vs_top=(vs_base=old_base)+1;")
  758.   (wt-nl "vs_base[0]=")
  759.   (case type
  760.         (void (wt "Cnil"))
  761.         (object (wt "x"))
  762.         (char (wt "code_char(x)"))
  763.         (int (when (zerop *space*) (wt "CMP"))
  764.              (wt "make_fixnum(x)"))
  765.         (float (wt "make_shortfloat(x)"))
  766.         (double (wt "make_longfloat(x)"))
  767.         )
  768.   (wt ";")
  769.   (wt-nl1 "}")
  770.   )
  771.  
  772. (defun t1defla (args) (declare (ignore args)))
  773.  
  774. (defun parse-cvspecs (x &aux (cvspecs nil))
  775.   (dolist** (cvs x (reverse cvspecs))
  776.     (cond ((symbolp cvs)
  777.            (push (list 'object (string-downcase (symbol-name cvs))) cvspecs))
  778.           ((stringp cvs) (push (list 'object cvs) cvspecs))
  779.           ((and (consp cvs)
  780.                 (member (car cvs) '(object char int float double)))
  781.            (dolist** (name (cdr cvs))
  782.              (push (list (car cvs)
  783.                          (cond ((symbolp name)
  784.                                 (string-downcase (symbol-name name)))
  785.                                ((stringp name) name)
  786.                                (t (cmperr "The C variable name ~s is illegal."
  787.                                           name))))
  788.                    cvspecs)))
  789.           (t (cmperr "The C variable specification ~s is illegal." cvs))))
  790.   )
  791.  
  792. (defun t3local-fun (closure-p clink ccb-vs fun lambda-expr
  793.                               &aux (level (if closure-p 0 (fun-level fun))))
  794.   (declare (fixnum level))
  795.   (wt-comment "local function " (if (fun-name fun) (fun-name fun) nil))
  796.   (wt-nl1 "static " (if closure-p "LC" "L") (fun-cfun fun) "(")
  797.   (dotimes* (n level (wt "base" n ")")) (wt "base" n ","))
  798.   (wt-nl1 "register object ")
  799.   (dotimes* (n level (wt "*base" n ";")) (wt "*base" n ","))
  800.   (let ((*vs* 0) (*max-vs* 0) (*clink* clink) (*ccb-vs* ccb-vs)
  801.         (*level* (1+ level)) (*initial-ccb-vs* ccb-vs)
  802.         (*exit* 'return) (*unwind-exit* '(return))
  803.         (*value-to-go* 'return) (*reservation-cmacro* (next-cmacro)))
  804.        (wt-nl1 "{    register object *base=vs_base;")
  805.        (wt-nl "register object *sup=base+VM" *reservation-cmacro* ";")
  806.        (if *safe-compile*
  807.            (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  808.            (wt-nl "vs_check;"))
  809.        (when *compiler-push-events* (wt-nl "ihs_check;"))
  810.        (if closure-p
  811.            (c2lambda-expr (caddr lambda-expr) (caddr (cddr lambda-expr)))
  812.            (c2lambda-expr (caddr lambda-expr) (caddr (cddr lambda-expr)) fun))
  813.        (wt-nl1 "}")
  814.        (push (cons *reservation-cmacro* *max-vs*) *reservations*))
  815.   )
  816.